PsL Monthly 1994 January/PSL Monthly Shareware CD-ROM (Public Software Library) (January 1994).iso/games/dos/board/chkr_pf.com/CHECKERS.PAS

Pascal/Delphi Source File | 1990-03-14 | 22.0 KB | 792 lines

Program Checkers;

Uses graph,crt,egadrv;  {egadrv is unit containing BGI driver}

(*                                                  *)
(*    A Proper Game of Draughts                     *)
(*                                                  *)
(*      Based on a program by Tim Hartnell          *)
(*    in Getting Acquainted With Your ZX81,         *)
(*       Creative Computing Press,1982.             *)
(*                                                  *)
(*   Board algorithm from Scientific Amer article.  *)
(*                                                  *)
(*     Requires EGA card                            *)
(*                                                  *)
(*    Peter Franchuk    3/2/90                      *)
(*       CIS ID [74146,225]                         *)
(*                                                  *)
(*                                                  *)
(*   Released to Public Domain                      *)
(*     for Personal use ONLY                        *)
(*                                                  *)

Const
  GDDrv='';   {for BGI driver if not registered}
  Direc:array[1..4] of integer=(-6,-7,6,7);

Type
  Pieces=(HuKing,HuMan,Blnk,CoMan,CoKing,OffBrd);
  Moverec=record
    row,col,value : integer;
    piece:pieces;
   end;

Var
  A : array [10..86] of Pieces;           {work array for pieces}
  Board : array [1..8,1..8] of byte;      {indices of squares--used for move}
  Use,Checker : array [1..12] of integer; {keep track of comp pieces location}
  jmpchk : array [24..72] of boolean;     {used to check for jumps}
  HuMove,Hufirst,Nmove,Njmp : boolean;
  HuName : string[10];
  PiecePtr : array [HuKing..CoKing] of pointer;  {images of pieces}
  FmSq,ToSq : Moverec;
  Total,Sum,Compcnt,KingCnt : word;
  ans : char;
  HuPiece,CoPiece : set of Pieces;

Procedure Set_Board;
  Var
    i,j,indx : integer;
    sqval : byte;
    strt : array [1..8] of byte;
  Begin
    HuPiece := [HuKing,HuMan];
    CoPiece := [CoKing,CoMan];
    for indx := 10 to 86 do A[indx] := offbrd;
    compcnt := 0;
    for indx := 69 to 72 do           {load up array with pieces}
     begin
      a[indx] := CoMan;
      inc(compcnt);checker[compcnt] := indx;
     end;
    for indx := 63 to 66 do
     begin
      a[indx] := Coman;
      inc(compcnt);checker[compcnt] := indx;
     end;
    for indx := 56 to 59 do
     begin
      a[indx] := Coman;
      inc(compcnt);checker[compcnt] := indx;
     end;
    for indx := 50 to 53 do a[indx] := blnk;
    for indx := 43 to 46 do a[indx] := blnk;
    for indx := 37 to 40 do a[indx] := HuMan;
    for indx := 30 to 33 do a[indx] := HuMan;
    for indx := 24 to 27 do a[indx] := Human;
    for i := 1 to 8 do for j := 1 to 8 do board[i,j] := 0;
    strt[1] := 72;strt[2] := 66;strt[3] := 59;
    strt[4] := 53;strt[5] := 46;
    strt[6] := 40;strt[7] := 33;strt[8] := 27;
    for i := 1 to 8 do
     begin
      if odd(i)
       then j := 2
       else j := 1;                    {load up board image}
      sqval := strt[i];
      while j<9 do
       begin
        board[i,j] := sqval;
        dec(sqval);inc(j,2);
       end;
     end;
    for i := 24 to 72 do jmpchk[i] := false;
    compcnt := 12;
    KingCnt := 0;
    total := 0;                        {initialize rest}
    sum := 0;
  End;

Procedure Draw_info;
  Var
    i,j : integer;
    ityp : pieces;
    Gd,Gm : integer;
    imsze : word;
  Begin
    SetFillStyle(SolidFill,LightRed);
    if Hufirst
     then j := 50
     else j := 300;
    i := 450;                          {draw and save checker images}
    FillEllipse(i,j,12,9);
    circle(i,j,9);circle(i,j,4);
    if Hufirst
     then j := 300
     else j := 50;
    i := 450;
    circle(i,j,12);circle(i,j,9);circle(i,j,4);
    imsze := Imagesize(1,1,33,25);
    for ityp := HuKing to CoKing do getmem(pieceptr[ityp],imsze);
    GetImage(434,38,466,62,pieceptr[CoMan]^);
    GetImage(1,1,33,25,pieceptr[blnk]^);
    GetImage(434,288,466,312,pieceptr[HuMan]^);
    j := 158;
    if Hufirst
     then i := 434
     else i := 334;
    GetImage(i,j,i+32,j+24,pieceptr[HuKing]^);
    if Hufirst
     then i := 334
     else i := 434;
    GetImage(i,j,i+32,j+24,pieceptr[CoKing]^);
    OuttextXY(330,50,'Computer');
    OutTextXY(330,300,HuName);
  End;

Procedure Who_first;
  Var
    ans,prmpt : char;
    Gd,Gm :integer;
    sx,sy :integer;
  Begin
    if registerBGIdriver(@EGAVGADriverProc)<0 then halt;
  {
     if not registering driver, comment out line above and be sure to have
      GdGrv constant defined to path of BGI driver at beginning of program.
  }
    Gd := EGA;Gm := EGAHi;
    Initgraph(gd,gm,gddrv);
    OutTextXY(362,130,'Checkers');
    SetFillStyle(SolidFill,LightRed);
    FillEllipse(350,170,12,9);
    OuttextXY(346,167,'K');
    circle(350,170,10);
    Circle(450,170,12);Circle(450,170,10);
    OuttextXY(446,167,'K');
    MoveTo(40,170);
    OutText('Your name, please : ');
    sx := GetX;sy := getY;
    ans := ' ';HuName := '';prmpt := '_';
    SetFillstyle(emptyfill,black);
    Repeat
     Bar(sx,sy,sx+80,sy+10);
     MoveTo(sx,sy);OutText(HuName+prmpt);
     Ans := readKey;
     if ans>#31
      then HuName := HuName+ans
      else if ans=#8 then HuName := copy(HuName,1,length(HuName)-1);
     HuName[1] := Upcase(HuName[1]);
    Until ans=#13;
    Bar(sx,sy,sx+80,sy+10);
    OutTextXY(sx,sy,HuName);
    OutTextXY(40,185,'Will you go first, '+HuName+' ? ');
    ans := ReadKey;
    HuFirst := ans in ['Y','y'];
    Draw_info;
    HuMove := Hufirst;
  End;

Procedure Draw_Board;
  Var cor,i,y :integer;
  Begin
    SetViewPort(36,65,334,311,ClipOn);
    SetFillstyle(Solidfill,Red);
    SetLinestyle(SolidLn,0,Thickwidth);
    SetColor(brown);
    bar(1,1,288,224);
    rectangle(1,1,288,224);
    cor := 28;y := 36;
    for i := 1 to 7 do
     begin
      line(y,0,y,224);                  {initial board}
      line(0,cor,288,cor);
      inc(cor,28);inc(y,36);
     end;
    for i := 1 to 3 do
     begin
      if odd(i)
       then cor := 2
       else cor :=1;
      while cor<9 do
       begin
        PutImage((cor-1)*36+2,(i-1)*28+2,pieceptr[CoMan]^,NormalPut);
        inc(cor,2);
       end;
     end;
    for i := 4 to 5 do
     begin
      if odd(i)
       then cor := 2
       else cor :=1;
      while cor<9 do
       begin
        PutImage((cor-1)*36+2,(i-1)*28+2,pieceptr[Blnk]^,NormalPut);
        inc(cor,2);
       end;
     end;
    for i := 6 to 8 do
     begin
      if odd(i)
       then cor := 2
       else cor :=1;
      while cor<9 do
       begin
        PutImage((cor-1)*36+2,(i-1)*28+2,pieceptr[HuMan]^,NormalPut);
        inc(cor,2);
       end;
     end;
    SetFillStyle(emptyFill,black);
    SetViewport(0,0,639,349,clipon);
    i := 50;y := 55; ans := '1';
    for cor := 1 to 8 do
     begin
      OutTextXY(i,y,ans);
      OutTextXY(i,295,ans);
      inc(i,36);ans := char( ord(ans) + 1);
     end;
    i := 24;y:=75; ans := 'A';
    for cor := 1 to 8 do
     begin
      OutTextXY(i,y,ans);
      inc(y,28);ans := char( ord(ans) +1);
     end;
    SetColor(white);
  End;

Procedure PlacePiece(v:integer;p:pieces);
  Var r,c:integer;
  Begin
     case v of
      72 : begin r := 1; c := 2 end;   27 : begin r := 8; c := 1 end;
      71 : begin r := 1; c := 4 end;   26 : begin r := 8; c := 3 end;
      70 : begin r := 1; c := 6 end;   25 : begin r := 8; c := 5 end;
      69 : begin r := 1; c := 8 end;   24 : begin r := 8; c := 7 end;
      66 : begin r := 2; c := 1 end;   59 : begin r := 3; c := 2 end;
      65 : begin r := 2; c := 3 end;   58 : begin r := 3; c := 4 end;
      64 : begin r := 2; c := 5 end;   57 : begin r := 3; c := 6 end;
      63 : begin r := 2; c := 7 end;   56 : begin r := 3; c := 8 end;
      53 : begin r := 4; c := 1 end;   46 : begin r := 5; c := 2 end;
      52 : begin r := 4; c := 3 end;   45 : begin r := 5; c := 4 end;
      51 : begin r := 4; c := 5 end;   44 : begin r := 5; c := 6 end;
      50 : begin r := 4; c := 7 end;   43 : begin r := 5; c := 8 end;
      40 : begin r := 6; c := 1 end;   33 : begin r := 7; c := 2 end;
      39 : begin r := 6; c := 3 end;   32 : begin r := 7; c := 4 end;
      38 : begin r := 6; c := 5 end;   31 : begin r := 7; c := 6 end;
      37 : begin r := 6; c := 7 end;   30 : begin r := 7; c := 8 end;
      end;
    SetViewPort(36,65,334,311,ClipOn);
    PutImage((c-1)*36+2,(r-1)*28+2,pieceptr[p]^,NormalPut);
    a[v] := p;
    SetViewPort(0,0,639,349,ClipOn);
  End;

Procedure Flash_piece(where:integer);
  Var ct,nb: integer;cpiece : pieces;
  Begin
   cpiece := a[where];
   if cpiece in HuPiece
    then nb := 2
    else nb := 4;
   for ct := 1 to nb do
    begin
     placepiece(where,blnk);
     delay(200);
     placepiece(where,cpiece);
     delay(100);
    end;
  End;

Procedure OpChkJmp(var Q:integer;z:integer);
  Var d : integer;
  Begin
    for d := 1 to 4 do                     {player piece can jump?}
    begin
     if (a[z]<>HuKing) and (d>2) then exit;
     if (a[z-direc[d]] in CoPiece) and (a[z-2*direc[d]]=blnk)
      then begin
       Q := direc[d];
       exit;
      end;
    end;
    Q := 0;
  End;


Procedure Player_move(var newmve : boolean);
  var
    rw,cl,j,i : integer;
    k1,k2 : char;
    good : boolean;

  Procedure Showmove;
    Begin
     flash_piece(fmsq.value);
     placePiece(fmsq.value,blnk);
     placePiece(tosq.value,fmsq.piece);
    End;

  Begin
    good := false;
    Setcolor(black);
    bar(335,90,630,270);
    Setcolor(white);
    OutTextXY(350,110,'Your move, '+HuName);
    if not newmve then
     begin
      j := 0;                        {can you really continue jump?}
      Opchkjmp(j,tosq.value);
      if j=0 then
       begin
        newmve := true;
        HuMove := false;
        exit;                        {you lied}
       end;
     end;
    if newmve
     then outtextxy(350,120,'Specifiy letter,number (or [ESC])')
     else outtextxy(355,120,'Continue your jump');
    repeat
     moveto(365,130);
     Outtext('Move from : ');
     bar(getx,130,550,140);
     if newmve
      then begin
        k1 := ' ';
        repeat
        k1 := upcase(readkey);
        until ((k1>='A') and (k1<='H')) or (k1=#27);
      end
      else k1 := char( tosq.row-1+ord('A') );
     bar(335,140,630,200);
     if k1=#27 then
      begin
       OutTextXY(340,150,'OK, GoodBye');
       delay(1500);
       closegraph;
       halt;
      end;
     Outtext(k1);
     rw := ord(k1)-ord('A') + 1;
     if newmve
      then begin
       k2 := ' ';
       repeat
       k2 := Readkey;
       until (k2>='1') and (k2<='8');
      end
      else k2 := char( tosq.col-1+ord('1') );
     outtext(k2);
     cl := ord(k2)-ord('1')+1;
     good := ( odd(rw) and (not odd(cl)) ) or ( (not odd(rw)) and odd(cl) );
     if not good then outtextXY(380,170,'You can''t do that');
     if good then
      begin
       FmSq.row := rw;FmSq.col := cl;
       Fmsq.value := Board[rw,cl];fmsq.piece := a[fmsq.value];
      end;
     if good then
      begin
       outtext(' to: ');
       k1 := ' ';
       repeat
       k1 := upcase(readkey);
       until (k1>='A') and (k1<='H');
       Outtext(k1);
       rw := ord(k1)-ord('A') + 1;
       k2 := ' ';
       repeat
       k2 := Readkey;
       until (k2>='1') and (k2<='8');
       outtext(k2);
       cl := ord(k2)-ord('1')+1;
      end;
     good := (odd(rw) and (not odd(cl))) or ((not odd(rw)) and odd(cl));

     if not good then outtextXY(380,170,'You can''t do that');

     if good then
      begin
       toSq.row := rw;toSq.col := cl;
       tosq.value := Board[rw,cl];tosq.piece := a[tosq.value];
      end;

     if good and jmpchk[fmsq.value] and (abs(fmsq.value-tosq.value)<=7)
      then begin
       good := false;
       OutTextXY(340,160,'You must make the jump.');
      end;

     if good and (fmsq.piece=Human) then begin
      good := (tosq.value-fmsq.value) > 0;
      if not good then outtextXY(380,170,'Only Kings move backwards');
      end;

     if good then begin
       good:=((fmsq.piece=human) or (fmsq.piece=huKing)) and (tosq.piece=blnk);
       if not good then
        begin outtextXY(340,180,'You must move YOUR man');
        outtextXY(340,190,' to an adjacent free space');end;
       end;

     if good then begin
       good := ( (abs(fmsq.value-tosq.value) mod 6)=0 ) or
        ( (abs(fmsq.value-tosq.value) mod 7)=0 );
       if not good then outtextXY(380,170,'Must move on the diagonal');
       end;

     if good and (abs(fmsq.value-tosq.value)>7) then begin
       good := a[ (fmsq.value+tosq.value) div 2 ] in CoPiece;
       if not good then outtextXY(380,170,'You can only jump an opponent');
       end;

     if (not newmve) and (not good) then tosq := fmsq;
    Until good;

    rw := 0;
    if abs(fmsq.value-tosq.value)>7 then     {is it a jump?}
     begin
      outtextXY(350,150,'Multiple jump?');
      ans := readkey;
      HuMove := ans in ['Y','y'];
      rw := (fmsq.value+tosq.value) div 2;
      a[rw] := blnk;
      j := 1;                                {remove the comp piece}
      while checker[j]<>rw do inc(j);
      if a[checker[j]]=CoKing then dec(KingCnt);
      if j<compcnt then
       for i := j to compcnt-1 do checker[i] := checker[i+1];
      dec(compcnt);
      inc(total);
      if (tosq.value>68) and (fmsq.piece=HuMan)
       then begin
        newmve := true;
        HuMove := false;
       end                                   {reaching Kings row ends move}
       else Newmve := false;
      Njmp := false;
     end
     else
      begin
       HuMove := false;
       Newmve := true;
       Njmp := true;
      end;
    ShowMove;
    if rw>0 then  placePiece(rw,blnk);
  End;

Procedure disp_status;
  Var
    cnt:string;
  Begin
    bar(438,38,472,62);
    SetTextStyle(Defaultfont,horizdir,2);
    str(sum,cnt);
    outtextXY(440,45,cnt);
    bar(438,288,472,312);                     {show the score}
    str(total,cnt);
    outtextXY(440,293,cnt);
    SetTextStyle(defaultfont,horizdir,1);
    if (sum=12) or (total=12) then
     begin
      bar(335,90,630,270);                    {game over}
      If sum=12 then
        begin
        SetTextstyle(defaultfont,horizdir,2);
        OutTextXY(350,100,'I WIN!');
        end;
      if total=12 then OutTextXY(360,100,'You win.');
      ans := readkey;
      Closegraph;
      halt;
     end;
  End;


Procedure Comp_move;
  Var
    Q,z,i,d,j : integer;

  Procedure CrownKings;
    Var z : integer;
    Begin
      for z := 69 to 72 do
       if a[z]=Human then
        begin
         a[z] := HuKing;
         placePiece(z,Huking);
        end;
      for z := 24 to 27 do
       if a[z]=Coman then
        begin
         a[z] := CoKing;
         inc(KingCnt);
         placePiece(z,CoKing);
        end;
    End;


  Procedure ChkHuman;
    Var
      i,Q :integer;
    Begin
      Q := 0;
      for i := 24 to 72 do
       if jmpchk[i] and (a[i] in HuPiece) then begin
        OpChkJmp(Q,i);
        if Q<>0 then begin
         OuttextXY(350,140,'You missed a jump');
         flash_piece(i);
         flash_piece(i);
         OuttextXY(355,150,'Hit any key to continue');
         ans := readkey;
         placepiece(i,blnk);
         inc(sum);
         disp_status;
         exit;
        end;
       end;
    End;

  Procedure ChkJmp(var Q:integer);
    Var d : integer;
    Begin
      for d := 1 to 4 do              {comp piece [z] has a jump?}
      begin
       if (a[z]<>CoKing) and (d>2) then exit;
       if (a[z+direc[d]] in HuPiece) and (a[z+2*direc[d]]=blnk)
         then begin
          Q := direc[d];
          exit;
       end;
      end;
      Q := 0;
    End;

  Procedure Do_Jmp;
    Var j : integer;
    Begin
      flash_piece(z);
      placePiece(z+2*Q,a[z]);
      j := 1;
      While checker[j]<>z do inc(j);
      placePiece(z,blnk);
      checker[j] := z+2*Q;
      inc(Sum);
      placePiece(z+Q,blnk);
    End;

  Procedure Do_Move(oldsq,amnt:integer);
    Var i,nwsq : integer;
    Begin
      nwsq := oldsq + amnt;
      flash_piece(oldsq);
      placepiece(nwsq,a[oldsq]);
      i := 1;
      while checker[i]<>oldsq do inc(i);
      checker[i] := nwsq;
      placepiece(oldsq,blnk);
    End;

  Procedure Random_move;
    Var
      z,d : integer;
      n,j : word;
      gmove : set of pieces;
    Begin
      n := compcnt;
      use := checker;
      while n>0 do
       begin
        j := 1 + Random(n);             {see if we can slide inbetween}
        if j>n then j := n;
        if j<1 then j := 1;
        if (n>2) and (j=n) then dec(j);
        z := use[j];
        for d := 1 to 2 do
         begin
          if (a[z+direc[d]]=blnk) and (not (a[z+2*direc[d]] in HuPiece))
            and (a[z-13]<>Blnk) and (a[z-1+2*(d mod 2)]<>Blnk)
           then begin
            Do_Move(z,direc[d]);
            exit;
           end;
          if (a[z]=CoKing) and (z<55) and (a[z-direc[d]]=blnk)
            and (not (a[z-2*direc[d]] in HuPiece))
            and (a[z+13]<>Blnk) and (a[z-1+2*(d div 2)]<>Blnk)
           then begin
            Do_Move(z,-direc[d]);
            exit;
           end;
         end;
        use[j] := use[n];
        dec(n);
       end;
      n := compcnt;
      use := checker;
      while n>0 do
       begin
        j := 1 + Random(n);
        if j<1 then j := 1;
        if j>n then j := n;
        if (n>2) and (j=n) then dec(j);
        z := use[j];
        for d := 2 downto 1 do                 {otherwize not into a jump}
         begin
          if (a[z+direc[d]]=blnk)
           and ((a[z]=CoMan) or (KingCnt=compcnt))
           and (not (a[z+2*direc[d]] in HuPiece))
           and (not (a[z+13] in HuPiece)) then
           begin
            Do_Move(z,direc[d]);
            exit;
           end;
          if (kingcnt>compcnt-2) and (a[z]=CoKing) and (z<55)
                     and (a[z-direc[d]]=blnk) and
           (not (a[z-2*direc[d]] in HuPiece)) and (not (a[z-13] in HuPiece))
           then begin
            Do_Move(z,-direc[d]);
            exit;
           end;
         end;
        use[j] := use[n];
        dec(n);
       end;
      n := compcnt;
      use := checker;
      while n>0 do
       begin
        j := 1 + Random(n);
        if j>n then j := n;
        if j<1 then j := 1;
        if (n>2) and (j=n) then dec(j);
        z := use[j];
        for d := 1 to 2 do                 {otherwize just move}
         begin
          if (a[z+direc[d]]=blnk) then
           begin
            Do_Move(z,direc[d]);
            exit;
           end;
          if (a[z]=CoKing) and (z<55) and (a[z-direc[d]]=blnk)
           then begin
            Do_Move(z,-direc[d]);
            exit;
           end;
         end;
        use[j] := use[n];
        dec(n);
       end;
      OuttextXY(350,100,'I concede');
      ans := readkey;                      {or give up}
      closegraph;                          {game over}
      halt;
    End;

  Begin
    CrownKings;
    bar(335,90,630,270);
    OutTextXY(350,110,'MY Move..');
    delay(1000);                     {gives player a chance to look at screen}

{    outtextXY(355,120,'Hit any key');
    ans := readkey; }        {alternate form for beginning computer move}


    if Njmp then ChkHuman;            {check for missed jumps}
    i := 1;Q :=0;
    while (Q=0) and (i<=compcnt) do
     begin
      z := checker[i];
      ChkJmp(Q);inc(i);               {can the computer jump?}
     end;
    if Q<>0
     then while Q<>0 do begin
      Do_Jmp;
      z := z+2*Q;
      Q := 0;                         {yes, do it}
      ChkJmp(Q);                      {and check for more}
     end
     else begin
      i := 1;
      while (Q=0) and (i<=compcnt) do
       begin
        d := 1;                         {check for blocking jump}
        z := checker[i];
        repeat
          j := direc[d];
           if (a[z+j] in HuPiece) and (a[z-j]=blnk) then
            begin
             if (a[z-2*j] in CoPiece)
              then Q := z-2*j
              else if (a[z+13] in CoPiece) then
               begin
                Q := z+13;
                j := direc[ (d mod 2) +1 ];
               end;
             end;
          if (Q=0) and (a[z+2*j]=CoKing) then
           begin
            j := -j;
            if (a[z+j] in HuPiece) and (a[z-j]=blnk)
              then Q := z-2*j;
           end;
          inc(d);
        until (Q<>0) or (d>2);
        inc(i);
       end;
      if Q<>0
       then Do_Move(Q,j)
       else begin
        i := 1;
        while (Q=0) and (i<=compcnt) do
         begin
          z := checker[i];
          if a[z]=CoKing then
           begin
            d := 3;
            repeat                       {can you use the king?}
             j := direc[d];
             if (a[z+j]=blnk) and (a[z+2*j]=HuMan)
              and (a[z+3*j]=blnk) then
               if (not (a[z-1+2*((d-2) div 2)] in Hupiece))
                then Q := z;
             inc(d);
            until (Q<>0) or (d>4);
           end;
          inc(i);
         end;
        if Q<>0
         then Do_Move(Q,j)
         else Random_move;                {else random move}
        end;
      end;
    for i := 24 to 72 do
      if not (a[i] in HuPiece)
       then jmpchk[i] := false
       else begin
        Q := 0;
        OpChkJmp(Q,i);                {set check array for human jumps}
        jmpchk[i] := Q<>0;
       end;
    Disp_status;
    HuMove := true;
    CrownKings;
    Nmove := true;
  End;

Procedure Play_game;
  Var
    forever : boolean;
  Begin
    forever := false;
    repeat
     if Humove then Player_move(Nmove);
     disp_status;
     if not Humove then Comp_move;
    until forever;
  End;


BEGIN
  Set_board;
  Who_first;
  Draw_board;
  Nmove := true;
  Randomize;
  Play_game;
END.